home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / static.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-05-11  |  57.2 KB  |  1,846 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * static.c:    Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Static Analysis for Gofer
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13.  
  14. #if MPW
  15. #pragma segment Static
  16. #endif
  17.  
  18. /* --------------------------------------------------------------------------
  19.  * local function prototypes:
  20.  * ------------------------------------------------------------------------*/
  21.  
  22. static Void  local checkTyconDefn    Args((Tycon));
  23. static Type  local depTypeExp        Args((Int,List,Type));
  24. static Void  local depConstr        Args((Int,List,Cell));
  25. static Void  local checkTyconGroup    Args((List));
  26. static Void  local addConstrs        Args((Tycon));
  27. static Name  local newConstr        Args((Tycon,Int,Type,Cell));
  28. static Void  local checkSynonyms    Args((List));
  29. static List  local visitSyn        Args((List,Tycon,List));
  30.  
  31. static Type  local fullExpand        Args((Type));
  32. static Type  local instantiateSyn    Args((Type,Type));
  33. static Cell  local fullExpPred        Args((Cell));
  34.  
  35. static List  local typeVarsIn        Args((Cell,List));
  36. static List  local maybeAppendVar    Args((Cell,List));
  37.  
  38. static List  local offsetTyvarsIn    Args((Type,List));
  39.  
  40. static Type  local checkSigType        Args((Int,String,Cell,Type));
  41.  
  42. static Void  local checkClassDefn    Args((Class));
  43. static Void  local depPredExp        Args((Int,List,Cell));
  44. static Void  local checkMems        Args((Class,List,Cell));
  45. static Void  local checkClassGroup    Args((List));
  46. static Void  local addMembers        Args((Class));
  47. static Name  local newMember        Args((Int,Int,Cell,Type));
  48.  
  49. static Void  local checkInstDefn        Args((Inst));
  50.  
  51. static List  local classBindings        Args((String,Class,List));
  52. static Int   local memberNumber         Args((Class,Text));
  53. static List  local numInsert            Args((Int,Cell,List));
  54.  
  55. static Void  local addNewPrim        Args((Int,Text,String,Cell));
  56.  
  57. static Cell  local checkPat        Args((Int,Cell));
  58. static Cell  local checkMaybeCnkPat    Args((Int,Cell));
  59. static Cell  local checkApPat        Args((Int,Int,Cell));
  60. static Void  local addPatVar        Args((Int,Cell));
  61. static Name  local conDefined        Args((Int,Text));
  62. static Void  local checkIsCfun        Args((Int,Cell));
  63. static Void  local checkCfunArgs    Args((Int,Cell,Int));
  64.  
  65. static Cell  local bindPat        Args((Int,Cell));
  66. static Void  local bindPats        Args((Int,List));
  67.  
  68. static List  local extractSigdecls    Args((List));
  69. static List  local extractBindings    Args((List));
  70. static List  local eqnsToBindings    Args((List));
  71. static Void  local notDefined        Args((Int,List,Cell));
  72. static Cell  local findBinding        Args((Text,List));
  73. static Void  local addSigDecl        Args((List,Cell));
  74. static Void  local setType        Args((Int,Cell,Cell,List));
  75.  
  76. static List  local dependencyAnal    Args((List));
  77. static List  local topDependAnal    Args((List));
  78. static Void  local addDepField        Args((Cell));
  79. static Void  local remDepField        Args((List));
  80. static Void  local remDepField1        Args((Cell));
  81. static Void  local clearScope        Args((Void));
  82. static Void  local withinScope        Args((List));
  83. static Void  local leaveScope        Args((Void));
  84.  
  85. static Void  local depBinding        Args((Cell));
  86. static Void  local depDefaults          Args((Class));
  87. static Void  local depInsts             Args((Inst));
  88. static Void  local depClassBindings     Args((List));
  89. static Void  local depAlt        Args((Cell));
  90. static Void  local depRhs        Args((Cell));
  91. static Void  local depGuard        Args((Cell));
  92. static Cell  local depExpr        Args((Int,Cell));
  93. static Void  local depPair        Args((Int,Cell));
  94. static Void  local depTriple        Args((Int,Cell));
  95. static Void  local depComp        Args((Int,Cell,List));
  96. static Void  local depCaseAlt        Args((Int,Cell));
  97. static Cell  local depVar        Args((Int,Cell));
  98.  
  99. static Int   local sccMin        Args((Int,Int));
  100. static List  local tscc            Args((List));
  101. static List  local cscc            Args((List));
  102. static List  local bscc            Args((List));
  103.  
  104. static Void  local addRSsigdecls    Args((Pair));
  105. static Void  local opDefined        Args((List,Cell));
  106. static Void  local allNoPrevDef        Args((Cell));
  107. static Void  local noPrevDef        Args((Int,Cell));
  108. static Void  local checkTypeIn        Args((Pair));
  109.  
  110. /* --------------------------------------------------------------------------
  111.  * Static analysis of type declarations:
  112.  *
  113.  * Type declarations come in two forms:
  114.  * - data declarations - define new constructed data types
  115.  * - type declarations - define new type synonyms
  116.  *
  117.  * A certain amount of work is carried out as the declarations are
  118.  * read during parsing.  In particular, for each type constructor
  119.  * definition encountered:
  120.  * - check that there is no previous definition of constructor
  121.  * - ensure type constructor not previously used as a class name
  122.  * - make a new entry in the type constructor table
  123.  * - record line number of declaration
  124.  * - Build separate lists of newly defined constructors for later use.
  125.  * ------------------------------------------------------------------------*/
  126.  
  127. Void tyconDefn(line,lhs,rhs,what)    /* process new type definition       */
  128. Int  line;                /* definition line number       */
  129. Cell lhs;                /* left hand side of definition       */
  130. Cell rhs;                /* right hand side of definition   */
  131. Cell what; {                /* SYNONYM/DATATYPE/etc...       */
  132.     Cell  t   = getHead(lhs);
  133.     Tycon new = findTycon(textOf(t));
  134.  
  135.     if (isNull(new)) {
  136.     if (nonNull(findClass(textOf(t)))) {
  137.         ERROR(line) "\"%s\" used as both class and type constructor",
  138.             textToStr(textOf(t))
  139.         EEND;
  140.     }
  141.     new = newTycon(textOf(t));
  142.     }
  143.     else if (tycon(new).defn!=PREDEFINED) {
  144.     ERROR(line) "Repeated definition of type constructor \"%s\"",
  145.             textToStr(textOf(t))
  146.     EEND;
  147.     }
  148.  
  149.     tycon(new).line  = line;
  150.     tycon(new).arity = argCount;
  151.     tycon(new).defn  = pair(lhs,rhs);
  152.     tycon(new).what  = what;
  153.     tyconDefns       = cons(new,tyconDefns);
  154.     if (what!=DATATYPE && what!=SYNONYM) {
  155.     typeInDefns     = cons(pair(new,what),typeInDefns);
  156.     tycon(new).what = RESTRICTSYN;
  157.     }
  158. }
  159.  
  160. Void setTypeIns(bs)            /* set local synonyms for given       */
  161. List bs; {                /* binding group           */
  162.     List cvs = typeInDefns;
  163.     for (; nonNull(cvs); cvs=tl(cvs)) {
  164.     Tycon c  = fst(hd(cvs));
  165.     List  vs = snd(hd(cvs));
  166.     for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
  167.         if (nonNull(findBinding(textOf(hd(vs)),bs))) {
  168.         tycon(c).what = SYNONYM;
  169.         break;
  170.         }
  171.     }
  172.     }
  173. }
  174.  
  175. Void clearTypeIns() {            /* clear list of local synonyms       */
  176.     for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
  177.     tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
  178. }
  179.  
  180. /* --------------------------------------------------------------------------
  181.  * Further analysis of Type declarations:
  182.  *
  183.  * In order to allow the definition of mutually recursive families of
  184.  * data types, the static analysis of the right hand sides of type
  185.  * declarations cannot be performed until all of the type declarations
  186.  * have been read.
  187.  *
  188.  * Once parsing is complete, we carry out the following:
  189.  *
  190.  * - check format of lhs, extracting list of bound vars and ensuring that
  191.  *   there are no repeated variables.
  192.  * - run dependency analysis on rhs to check that only bound type vars
  193.  *   appear in type and that all constructors are defined.
  194.  *   Replace type variables by offsets, constructors by Tycons.
  195.  * - use list of dependents to sort into strongly connected components.
  196.  * - ensure that there is not more than one synonym in each group.
  197.  * - kind-check each group of type definitions.
  198.  *
  199.  * - check that there are no previous definitions for constructor
  200.  *   functions in data type definitions.
  201.  * - install synonym expansions and constructor definitions.
  202.  * ------------------------------------------------------------------------*/
  203.  
  204. static List tyconDeps = NIL;        /* list of dependent type constrs  */
  205.  
  206. static Void local checkTyconDefn(d)    /* validate type constructor defn  */
  207. Tycon d; {
  208.     Cell lhs    = fst(tycon(d).defn);
  209.     Cell rhs    = snd(tycon(d).defn);
  210.     Int  line   = tycon(d).line;
  211.     List tyvars = getArgs(lhs);
  212.     List temp;
  213.                     /* check for repeated tyvars on lhs*/
  214.     for (temp=tyvars; nonNull(temp); temp=tl(temp))
  215.     if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
  216.         ERROR(line) "Repeated type variable \"%s\" on left hand side",
  217.             textToStr(textOf(hd(temp)))
  218.         EEND;
  219.     }
  220.  
  221.     tyconDeps = NIL;            /* find dependents           */
  222.     switch (tycon(d).what) {
  223.     case RESTRICTSYN :
  224.     case SYNONYM     : rhs = depTypeExp(line,tyvars,rhs);
  225.                if (cellIsMember(d,tyconDeps)) {
  226.                    ERROR(line) "Recursive type synonym \"%s\"",
  227.                        textToStr(tycon(d).text)
  228.                    EEND;
  229.                }
  230.                break;
  231.  
  232.     case DATATYPE     : map2Proc(depConstr,line,tyvars,rhs);
  233.                break;
  234.  
  235.     default         : internal("checkTyconDefn");
  236.     }
  237.  
  238.     tycon(d).defn = rhs;
  239.     tycon(d).kind = tyconDeps;
  240.     tyconDeps      = NIL;
  241. }
  242.  
  243. static Type local depTypeExp(line,tyvars,type)
  244. Int  line;
  245. List tyvars;
  246. Type type; {
  247.     switch (whatIs(type)) {
  248.     case AP        : fst(type) = depTypeExp(line,tyvars,fst(type));
  249.               snd(type) = depTypeExp(line,tyvars,snd(type));
  250.               break;
  251.  
  252.     case VARIDCELL    : {   Int offset = 0;
  253.                   while (nonNull(tyvars) &&
  254.                     textOf(type)!=textOf(hd(tyvars))) {
  255.                   tyvars = tl(tyvars);
  256.                   offset++;
  257.                   }
  258.                   if (isNull(tyvars)) {
  259.                   ERROR(line) "Undefined type variable \"%s\"",
  260.                           textToStr(textOf(type))
  261.                   EEND;
  262.                   }
  263.                   return mkOffset(offset);
  264.               }
  265.  
  266.     case CONIDCELL    : {   Tycon tc = findTycon(textOf(type));
  267.                   if (isNull(tc)) {
  268.                   ERROR(line)
  269.                       "Undefined type constructor \"%s\"",
  270.                       textToStr(textOf(type))
  271.                   EEND;
  272.                   }
  273.                   if (cellIsMember(tc,tyconDefns) &&
  274.                   !cellIsMember(tc,tyconDeps))
  275.                   tyconDeps = cons(tc,tyconDeps);
  276.                   return tc;
  277.               }
  278.  
  279.     case TUPLE    :
  280.     case UNIT    :
  281.     case LIST    :
  282.     case ARROW    : break;
  283.  
  284.     default        : internal("depTypeExp");
  285.     }
  286.     return type;
  287. }
  288.  
  289. static Void local depConstr(line,tyvars,constr)
  290. Int  line;
  291. List tyvars;
  292. Cell constr; {
  293.     for (; isAp(constr); constr=fun(constr))
  294.     arg(constr) = depTypeExp(line,tyvars,arg(constr));
  295. }
  296.  
  297. static Void local checkTyconGroup(ts)    /* validate mutually recursive gp  */
  298. List ts; {                /* of type constructors           */
  299.  
  300.     kindTyconGroup(ts);            /* assign kinds to each tycon       */
  301.     mapProc(addConstrs,ts);        /* add definitions for constructor */
  302.                     /* functions of data types       */
  303. }
  304.  
  305. static Void local addConstrs(t)        /* Add definitions of constructor  */
  306. Tycon t; {
  307.     if (tycon(t).what==DATATYPE) {
  308.     Type lhs      = t;
  309.     List cs          = tycon(t).defn;
  310.     Int  constrNo = 0;
  311.     Int  i;
  312.  
  313.     for (i=0; i<tycon(t).arity; ++i)
  314.         lhs = ap(lhs,mkOffset(i));
  315.  
  316.     for (; nonNull(cs); cs=tl(cs))
  317.         hd(cs) = newConstr(t,constrNo++,lhs,hd(cs));
  318.     }
  319. }
  320.  
  321. static Name local newConstr(t,num,lhs,c)/* Make definition for constructor */
  322. Tycon t;
  323. Int   num;
  324. Type  lhs;
  325. Cell  c; {
  326.     Type type = lhs;
  327.     Int  arity;
  328.     Name n;
  329.  
  330.     for (arity=0; isAp(c); arity++) {    /* calculate type of constructor   */
  331.     Type t = fun(c);
  332.     fun(c) = ARROW;
  333.     type   = ap(c,type);
  334.         c      = t;
  335.     }
  336.     if (tycon(t).arity>0)        /* add `universal quantifiers'       */
  337.     type = mkPolyType(tycon(t).kind,type);
  338.  
  339.     n = findName(textOf(c));        /* add definition to name table       */
  340.  
  341.     if (isNull(n))
  342.     n = newName(textOf(c));
  343.     else if (name(n).defn!=PREDEFINED) {
  344.     ERROR(tycon(t).line)
  345.         "Repeated definition for constructor function \"%s\"",
  346.         textToStr(name(n).text)
  347.     EEND;
  348.     }
  349.  
  350.     name(n).line   = tycon(t).line;
  351.     name(n).arity  = arity;
  352.     name(n).number = num;
  353.     name(n).type   = type;
  354.     name(n).defn   = CFUN;
  355.  
  356.     return n;
  357. }
  358.  
  359. static Void local checkSynonyms(ts)    /* check for mutually recursive       */
  360. List ts; {                /* synonyms in list of tycons ts   */
  361.     List syns = NIL;
  362.     for (; nonNull(ts); ts=tl(ts))    /* build list of all synonyms       */
  363.     if (tycon(hd(ts)).what!=DATATYPE)
  364.         syns = cons(hd(ts),syns);
  365.     while (nonNull(syns))        /* then visit each synonym       */
  366.     syns = visitSyn(NIL,hd(syns),syns);
  367. }
  368.  
  369. static List local visitSyn(path,t,syns)    /* visit synonym definition to look*/
  370. List  path;                /* for cycles               */
  371. Tycon t;
  372. List  syns; {
  373.     if (cellIsMember(t,path)) {        /* every elt in path depends on t  */
  374.     ERROR(tycon(t).line)
  375.         "Type synonyms \"%s\" and \"%s\" are mutually recursive",
  376.         textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
  377.     EEND;
  378.     }
  379.     else {
  380.     List ds    = tycon(t).kind;
  381.         List path1 = NIL;
  382.     for (; nonNull(ds); ds=tl(ds))
  383.         if (cellIsMember(hd(ds),syns)) {
  384.         if (isNull(path1))
  385.             path1 = cons(t,path);
  386.         syns = visitSyn(path1,hd(ds),syns);
  387.         }
  388.     }
  389.     tycon(t).defn = fullExpand(tycon(t).defn);
  390.     return removeCell(t,syns);
  391. }
  392.  
  393. /* --------------------------------------------------------------------------
  394.  * Expanding out all type synonyms in a type expression:
  395.  * ------------------------------------------------------------------------*/
  396.  
  397. static Type local fullExpand(t)        /* find full expansion of type exp */
  398. Type t; {                /* assuming that all relevant      */
  399.     Cell h = t;                /* synonym defns of lower rank have*/
  400.      Int  n = 0;                /* already been fully expanded       */
  401.     for (; isAp(h); h=fun(h), n++)
  402.      arg(h) = fullExpand(arg(h));
  403.     if (isSynonym(h) && n==tycon(h).arity)
  404.         t = instantiateSyn(tycon(h).defn,t);
  405.     return t;
  406. }
  407.  
  408. static Type local instantiateSyn(t,env)    /* instantiate type according using*/
  409. Type t;                    /* env to determine appropriate    */
  410. Type env; {                /* values for OFFSET type vars       */
  411.     switch (whatIs(t)) {
  412.         case AP      : return ap(instantiateSyn(fun(t),env),
  413.                                  instantiateSyn(arg(t),env));
  414.  
  415.         case OFFSET  : return nthArg(offsetOf(t),env);
  416.  
  417.     default         : return t;
  418.     }
  419. }
  420.  
  421. static Cell local fullExpPred(p)    /* find full expansion of predicate*/
  422. Cell p; {
  423.     Cell h = p;
  424.     while (isAp(h)) {
  425.     arg(h) = fullExpand(arg(h));
  426.     h      = fun(h);
  427.     }
  428.     return p;
  429. }
  430.  
  431. /* --------------------------------------------------------------------------
  432.  * Calculate set of variables appearing in a given type expression (possibly
  433.  * qualified) as a list of distinct values.  The order in which variables
  434.  * appear in the list is the same as the order in which those variables
  435.  * occur in the type expression when read from left to right.
  436.  * ------------------------------------------------------------------------*/
  437.  
  438. static List local typeVarsIn(type,vs)  /* calculate list of type variables */
  439. Cell type;                   /* used in type expression, reading */
  440. List vs; {                   /* from left to right           */
  441.     switch (whatIs(type)) {
  442.     case AP        : return typeVarsIn(snd(type),
  443.                        typeVarsIn(fst(type),
  444.                               vs));
  445.     case VARIDCELL :
  446.     case VAROPCELL : return maybeAppendVar(type,vs);
  447.  
  448.     case QUAL      : {   List qs = fst(snd(type));
  449.                  for (; nonNull(qs); qs=tl(qs))
  450.                  vs = typeVarsIn(hd(qs),vs);
  451.                  return typeVarsIn(snd(snd(type)),vs);
  452.              }
  453.     }
  454.     return vs;
  455. }
  456.  
  457. static List local maybeAppendVar(v,vs) /* append variable to list if not   */
  458. Cell v;                    /* already included           */
  459. List vs; {
  460.     Text t = textOf(v);
  461.     List p = NIL;
  462.     List c = vs;
  463.  
  464.     while (nonNull(c)) {
  465.     if (textOf(hd(c))==t)
  466.         return vs;
  467.     p = c;
  468.     c = tl(c);
  469.     }
  470.  
  471.     if (nonNull(p))
  472.     tl(p) = cons(v,NIL);
  473.     else
  474.     vs    = cons(v,NIL);
  475.  
  476.     return vs;
  477. }
  478.  
  479. /* --------------------------------------------------------------------------
  480.  * Check for ambiguous types:
  481.  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
  482.  * ------------------------------------------------------------------------*/
  483.  
  484. static List local offsetTyvarsIn(t,vs)    /* add list of offset tyvars in t  */
  485. Type t;                    /* to list vs               */
  486. List vs; {
  487.     switch (whatIs(t)) {
  488.     case AP        : return offsetTyvarsIn(fun(t),offsetTyvarsIn(snd(t),vs));
  489.  
  490.     case OFFSET : if (cellIsMember(t,vs))
  491.               return vs;
  492.               else
  493.               return cons(t,vs);
  494.  
  495.     case QUAL   : return offsetTyvarsIn(snd(t),vs);
  496.  
  497.     default        : return vs;
  498.     }
  499. }
  500.  
  501. Bool isAmbiguous(type)            /* Determine whether type is       */
  502. Type type; {                /* ambiguous                */
  503.     if (isPolyType(type))
  504.     type = monoTypeOf(type);
  505.     if (whatIs(type)==QUAL) {        /* only qualified types can be       */
  506.     List tvps = offsetTyvarsIn(fst(snd(type)),NIL);    /* ambiguous       */
  507.     List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
  508.     while (nonNull(tvps) && cellIsMember(hd(tvps),tvts))
  509.         tvps = tl(tvps);
  510.     return nonNull(tvps);
  511.     }
  512.     return FALSE;
  513. }
  514.  
  515. Void ambigError(line,where,e,type)    /* produce error message for       */
  516. Int    line;                /* ambiguity               */
  517. String where;
  518. Cell   e;
  519. Type   type; {
  520.     ERROR(line) "Ambiguous type signature in %s", where ETHEN
  521.     ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
  522.     ERRTEXT "\n*** assigned to    : " ETHEN ERREXPR(e);
  523.     ERRTEXT "\n"
  524.     EEND;
  525. }
  526.  
  527. /* --------------------------------------------------------------------------
  528.  * Type expressions appearing in type signature declarations and expressions
  529.  * also require static checking, but unlike type expressions in type decls,
  530.  * they may introduce arbitrary new type variables.  The static analysis
  531.  * required here is:
  532.  *   - ensure that each type constructor is defined and used with the
  533.  *     correct number of arguments.
  534.  *   - replace type variables by offsets, constructor names by Tycons.
  535.  *   - ensure that type is well-kinded.
  536.  * ------------------------------------------------------------------------*/
  537.  
  538. static Type local checkSigType(line,where,e,type)
  539. Int    line;                   /* check validity of type expression*/
  540. String where;                   /* in explicit type signature       */
  541. Cell   e;
  542. Type   type; {
  543.     List tyvars = typeVarsIn(type,NIL);
  544.     Int  n      = length(tyvars);
  545.  
  546.     if (whatIs(type)==QUAL) {
  547.     map2Proc(depPredExp,line,tyvars,fst(snd(type)));
  548.     snd(snd(type)) = depTypeExp(line,tyvars,snd(snd(type)));
  549.  
  550.     if (isAmbiguous(type))
  551.         ambigError(line,where,e,type);
  552.     }
  553.     else
  554.     type = depTypeExp(line,tyvars,type);
  555.  
  556.     if (n>0) {
  557.     if (n>=num_offsets) {
  558.         ERROR(line) "Too many type variables (%d offsets) in %s\n", 
  559.                 num_offsets, where
  560.         EEND;
  561.     }
  562.     type = mkPolyType(mkSelect(n),type);
  563.     }
  564.  
  565.     kindSigType(line,type);        /* check that type is well-kinded  */
  566.     return type;
  567. }
  568.  
  569. /* --------------------------------------------------------------------------
  570.  * Static analysis of class declarations:
  571.  *
  572.  * Performed in a similar manner to that used for type declarations.
  573.  *
  574.  * The first part of the static analysis is performed as the declarations
  575.  * are read during parsing:
  576.  * - no previous definition for class
  577.  * - class name not previously used as a type constructor
  578.  * - make new entry in class table
  579.  * - determine arity of class
  580.  * - record line number of declaration
  581.  * - build list of classes defined in current script for use in later
  582.  *   stages of static analysis.
  583.  * ------------------------------------------------------------------------*/
  584.  
  585. Void classDefn(line,head,ms)           /* process new class definition       */
  586. Int  line;                   /* definition line number       */
  587. Cell head;                   /* class header :: ([Supers],Class) */
  588. List ms; {                   /* class definition body           */
  589.     Text  ct    = textOf(getHead(snd(head)));
  590.     Int   arity = argCount;
  591.     Class new   = findClass(ct);
  592.  
  593.     if (isNull(new)) {
  594.     if (nonNull(findTycon(ct))) {
  595.         ERROR(line) "\"%s\" used as both class and type constructor",
  596.             textToStr(ct)
  597.         EEND;
  598.     }
  599.     new = newClass(ct);
  600.     }
  601.     else if (class(new).head!=PREDEFINED) {
  602.     ERROR(line) "Repeated definition of type class \"%s\"",
  603.             textToStr(ct)
  604.     EEND;
  605.     }
  606.  
  607.     class(new).arity    = arity;
  608.     class(new).line    = line;
  609.     class(new).head     = snd(head);
  610.     class(new).supers    = fst(head);
  611.     class(new).members    = ms;
  612.     classDefns        = cons(new,classDefns);
  613. }
  614.  
  615. /* --------------------------------------------------------------------------
  616.  * Further analysis of class declarations:
  617.  *
  618.  * Full static analysis of class definitions must be postponed until the
  619.  * complete script has been read and all static analysis on type definitions
  620.  * has been completed.
  621.  *
  622.  * Once this has been achieved, we carry out the following checks on each
  623.  * class definition:
  624.  *
  625.  * - check that class header has distinct type variable arguments.
  626.  * - convert class header to predicate skeleton.
  627.  * - check that superclasses are well-formed, replace by skeletons.
  628.  * - calculate list of dependent superclasses.
  629.  *
  630.  * - split body of class into members and declarations
  631.  * - make new name entry for each member function
  632.  * - record member function number (eventually an offset into dictionary!)
  633.  * - no member function has a previous definition ...
  634.  * - no member function is mentioned more than once in the list of members
  635.  * - each member function type is valid, replace vars by offsets
  636.  * - qualify each member function type by class header
  637.  * - only bindings for members appear in defaults
  638.  * - only function bindings appear in defaults
  639.  * ------------------------------------------------------------------------*/
  640.  
  641. static Void local checkClassDefn(c)    /* validate class definition       */
  642. Class c; {
  643.     List tyvars = NIL;
  644.     Int  args   = 0;
  645.     Int  i;
  646.     Cell temp;
  647.  
  648.     /* build list of type variables in class header */
  649.  
  650.     for (temp=class(c).head; isAp(temp); temp=fun(temp)) {
  651.     if (!isVar(arg(temp))) {
  652.         ERROR(class(c).line) "Type variable required in class header"
  653.         EEND;
  654.     }
  655.     if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
  656.         ERROR(class(c).line)
  657.         "Repeated type variable \"%s\" in class header",
  658.         textToStr(textOf(arg(temp)))
  659.         EEND;
  660.     }
  661.     tyvars = cons(arg(temp),tyvars);
  662.     args++;
  663.     }
  664.  
  665.     for (temp=class(c).head, i=args-1; i>0; temp=fun(temp), i--)
  666.     arg(temp) = mkOffset(i);
  667.     arg(temp) = mkOffset(0);
  668.     fun(temp) = c;
  669.  
  670.     class(c).sig = NIL;            /* validate superclass predicates  */
  671.     for (temp=class(c).supers; nonNull(temp); temp=tl(temp)) {
  672.     Class c0 = NIL;
  673.     depPredExp(class(c).line,tyvars,hd(temp));
  674.     c0 = getHead(hd(temp));
  675.     if (c0!=c && cellIsMember(c0,classDefns)
  676.           && !cellIsMember(c0,class(c).sig))
  677.         class(c).sig = cons(c0,class(c).sig);
  678.     }
  679.  
  680.     class(c).numSupers = length(class(c).supers);
  681.     temp               = class(c).members;
  682.     class(c).members   = extractSigdecls(temp);
  683.     class(c).defaults  = extractBindings(temp);
  684.     map2Proc(checkMems,c,tyvars,class(c).members);
  685. }
  686.  
  687. static Void local depPredExp(line,tyvars,pred)
  688. Int  line;
  689. List tyvars;
  690. Cell pred; {
  691.     Int   args = 0;
  692.     Class c;
  693.  
  694.     for (;;) {                /* parser ensures # args >= 1       */
  695.     arg(pred) = depTypeExp(line,tyvars,arg(pred));
  696.     args++;
  697.     if (isAp(fun(pred)))
  698.         pred = fun(pred);
  699.     else
  700.         break;
  701.     }
  702.  
  703.     if (isNull(c = findClass(textOf(fun(pred))))) {
  704.     ERROR(line) "Undefined class \"%s\"", textToStr(textOf(fun(pred)))
  705.     EEND;
  706.     }
  707.     fun(pred) = c;
  708.  
  709.     if (args!=class(c).arity) {
  710.     ERROR(line) "Wrong number of arguments for class \"%s\"",
  711.             textToStr(class(c).text)
  712.     EEND;
  713.     }
  714. }
  715.  
  716. static Void local checkMems(c,tyvars,m)    /* check member function details   */
  717. Class c;
  718. List  tyvars;
  719. Cell  m; {
  720.     Int  line = intOf(fst3(m));
  721.     List vs   = snd3(m);
  722.     Type t    = thd3(m);
  723.  
  724.     tyvars    = typeVarsIn(t,tyvars);
  725.     t          = mkPolyType(mkSelect(length(tyvars)),
  726.                ap(QUAL,pair(singleton(class(c).head),
  727.                     depTypeExp(line,tyvars,t))));
  728.  
  729.     if (isAmbiguous(t))
  730.     ambigError(line,"class declaration",hd(vs),t);
  731.  
  732.     thd3(m)  = t;                /* save type           */
  733.     tyvars   = take(class(c).arity,tyvars);    /* delete extra type vars  */
  734. }
  735.  
  736. static Void local checkClassGroup(cs)    /* validate mutually recursive gp  */
  737. List cs; {                /* of type classes           */
  738.     kindClassGroup(cs);
  739.     mapProc(addMembers,cs);
  740. }
  741.  
  742. static Void local addMembers(c)        /* Add definitions of member funs  */
  743. Class c; {
  744.     Int  mno   = 1;            /* member function number       */
  745.     List mfuns = NIL;            /* list of member functions       */
  746.     List ms    = class(c).members;
  747.  
  748.     for (; nonNull(ms); ms=tl(ms)) {    /* cycle through each sigdecl       */
  749.     Int  line = intOf(fst3(hd(ms)));
  750.     List vs   = rev(snd3(hd(ms)));
  751.     Type t    = thd3(hd(ms));
  752.     for (; nonNull(vs); vs=tl(vs))
  753.         mfuns = cons(newMember(line,mno++,hd(vs),t),mfuns);
  754.     }
  755.     class(c).members    = rev(mfuns);    /* save list of members           */
  756.     class(c).numMembers = length(class(c).members);
  757.     class(c).defaults   = classBindings("class",c,class(c).defaults);
  758. }
  759.  
  760. static Name local newMember(l,no,v,t)    /* Make definition for member fn   */
  761. Int  l;
  762. Int  no;
  763. Cell v;
  764. Type t; {
  765.     Name m = findName(textOf(v));
  766.  
  767.     if (isNull(m))
  768.     m = newName(textOf(v));
  769.     else if (name(m).defn!=PREDEFINED) {
  770.     ERROR(l) "Repeated definition for member function \"%s\"",
  771.          textToStr(name(m).text)
  772.     EEND;
  773.     }
  774.  
  775.     name(m).line   = l;
  776.     name(m).arity  = 1;
  777.     name(m).number = no;
  778.     name(m).type   = t;
  779.     name(m).defn   = MFUN;
  780.  
  781.     return m;
  782. }
  783.  
  784. /* --------------------------------------------------------------------------
  785.  * Static analysis of instance declarations:
  786.  *
  787.  * The first part of the static analysis is performed as the declarations
  788.  * are read during parsing:
  789.  * - make new entry in instance table
  790.  * - record line number of declaration
  791.  * - build list of instances defined in current script for use in later
  792.  *   stages of static analysis.
  793.  * ------------------------------------------------------------------------*/
  794.  
  795. Void instDefn(line,head,ms)           /* process new instance definition  */
  796. Int  line;                   /* definition line number       */
  797. Cell head;                   /* inst header :: (context,Class)   */
  798. List ms; {                   /* instance members           */
  799.     Inst new             = newInst();
  800.     inst(new).line       = line;
  801.     inst(new).specifics  = fst(head);
  802.     inst(new).head     = snd(head);
  803.     inst(new).implements = ms;
  804.     instDefns            = cons(new,instDefns);
  805. }
  806.  
  807. /* --------------------------------------------------------------------------
  808.  * Further static analysis of instance declarations:
  809.  *
  810.  * Makes the following checks:
  811.  * - Class part of header is a valid class expression C t1 ... tn not
  812.  *   overlapping with any other instance in class C.
  813.  * - Each element of context is a valid class expression, with type vars
  814.  *   drawn from the types t1,...,tn.
  815.  * - replace type vars in class header by offsets, validate all types etc.
  816.  * - All bindings are function bindings
  817.  * - All bindings define member functions for class C
  818.  * - Arrange bindings into appropriate order for member list
  819.  * - No top level type signature declarations
  820.  * ------------------------------------------------------------------------*/
  821.  
  822. static Void local checkInstDefn(in)    /* validate instance declaration    */
  823. Inst in; {
  824.     Int  line   = inst(in).line;
  825.     List tyvars = typeVarsIn(inst(in).head,NIL);
  826.  
  827.     depPredExp(line,tyvars,inst(in).head);
  828.     map2Proc(depPredExp,line,tyvars,inst(in).specifics);
  829.     inst(in).cl = getHead(inst(in).head);
  830.     kindInst(in,length(tyvars));
  831.     inst(in).head = fullExpPred(inst(in).head);
  832.     insertInst(line,inst(in).cl,in);
  833.     inst(in).numSpecifics = length(inst(in).specifics);
  834.  
  835.     if (nonNull(extractSigdecls(inst(in).implements))) {
  836.         ERROR(line) "Type signature decls not permitted in instance decl"
  837.         EEND;
  838.     }
  839.  
  840.     inst(in).implements = classBindings("instance",
  841.                                         inst(in).cl,
  842.                                         extractBindings(inst(in).implements));
  843. }
  844.  
  845. /* --------------------------------------------------------------------------
  846.  * Process class and instance declaration binding groups:
  847.  * ------------------------------------------------------------------------*/
  848.  
  849. static List local classBindings(where,c,bs)
  850. String where;                          /* check validity of bindings bs for*/
  851. Class  c;                              /* class c (or an instance of c)    */
  852. List   bs; {                           /* sort into approp. member order   */
  853.     List nbs = NIL;
  854.  
  855.     for (; nonNull(bs); bs=tl(bs)) {
  856.         Cell b  = hd(bs);
  857.         Name nm = newName(inventText());   /* pick name for implementation */
  858.         Int  mno;
  859.  
  860.         if (!isVar(fst(b))) {          /* only allows function bindings    */
  861.             ERROR(rhsLine(snd(snd(snd(b)))))
  862.                "Pattern binding illegal in %s declaration", where
  863.             EEND;
  864.         }
  865.  
  866.         mno = memberNumber(c,textOf(fst(b)));
  867.  
  868.         if (mno==0) {
  869.             ERROR(rhsLine(snd(hd(snd(snd(b))))))
  870.                 "No member \"%s\" in class \"%s\"",
  871.                 textToStr(textOf(fst(b))),
  872.                 textToStr(class(c).text)
  873.             EEND;
  874.         }
  875.  
  876.         name(nm).defn = snd(snd(b));   /* save definition of implementation*/
  877.         nbs = numInsert(mno-1,nm,nbs);
  878.     }
  879.     return nbs;
  880. }
  881.  
  882. static Int local memberNumber(c,t)     /* return number of member function */
  883. Class c;                               /* with name t in class c           */
  884. Text  t; {                             /* return 0 if not a member         */
  885.     List ms = class(c).members;
  886.     for (; nonNull(ms); ms=tl(ms))
  887.         if (t==name(hd(ms)).text)
  888.             return name(hd(ms)).number;
  889.     return 0;
  890. }
  891.  
  892. static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
  893. Int  n;                                /* filling gaps with NIL            */
  894. Cell x;
  895. List xs; {
  896.     List start = isNull(xs) ? cons(NIL,NIL) : xs;
  897.  
  898.     for (xs=start; 0<n--; xs=tl(xs))
  899.         if (isNull(tl(xs)))
  900.             tl(xs) = cons(NIL,NIL);
  901.     hd(xs) = x;
  902.     return start;
  903. }
  904.  
  905. /* --------------------------------------------------------------------------
  906.  * Primitive definitions are usually only included in the first script
  907.  * file read - the prelude.  A primitive definition associates a variable
  908.  * name with a string (which identifies a built-in primitive) and a type.
  909.  * ------------------------------------------------------------------------*/
  910.  
  911. Void primDefn(line,prims,type)           /* Handle primitive definitions       */
  912. Int  line;
  913. List prims;
  914. Cell type; {
  915.     type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
  916.     for (; nonNull(prims); prims=tl(prims))
  917.     addNewPrim(line,
  918.            textOf(fst(hd(prims))),
  919.            textToStr(textOf(snd(hd(prims)))),
  920.            type);
  921. }
  922.  
  923. static Void local addNewPrim(l,vn,s,t)    /* make binding of variable vn to  */
  924. Int    l;                /* primitive function referred       */
  925. Text   vn;                /* to by s, with given type t       */
  926. String s;                /* return TRUE if vn already bound */
  927. Cell   t;{
  928.     Name n = findName(vn);
  929.  
  930.     if (isNull(n))
  931.         n = newName(vn);
  932.     else if (name(n).defn!=PREDEFINED) {
  933.         ERROR(l) "Redeclaration of primitive \"%s\"", textToStr(vn)
  934.         EEND;
  935.     }
  936.  
  937.     addPrim(l,n,s,t);
  938. }
  939.  
  940. /* --------------------------------------------------------------------------
  941.  * Static analysis of patterns:
  942.  *
  943.  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
  944.  * makes the following checks:
  945.  *  - Patterns are well formed (according to pattern syntax), including the
  946.  *    special case of (n+k) patterns.
  947.  *  - All constructor functions have been defined and are used with the
  948.  *    correct number of arguments.
  949.  *  - No variable name is used more than once in a pattern.
  950.  *
  951.  * The list of pattern variables occuring in each pattern is accumulated in
  952.  * a global list `patVars', which must be initialised to NIL at appropriate
  953.  * points before using these routines to check for valid patterns.  This
  954.  * mechanism enables the pattern checking routine to be mapped over a list
  955.  * of patterns, ensuring that no variable occurs more than once in the
  956.  * complete pattern list (as is required on the lhs of a function defn).
  957.  * ------------------------------------------------------------------------*/
  958.  
  959. static List patVars;               /* list of vars bound in pattern    */
  960.  
  961. static Cell local checkPat(line,p)     /* Check valid pattern syntax       */
  962. Int  line;
  963. Cell p; {
  964.     switch (whatIs(p)) {
  965.     case VARIDCELL :
  966.     case VAROPCELL : addPatVar(line,p);
  967.              break;
  968.  
  969.     case AP        : return checkMaybeCnkPat(line,p);
  970.  
  971.     case NAME      :
  972.     case CONIDCELL :
  973.     case CONOPCELL : return checkApPat(line,0,p);
  974.  
  975.     case UNIT      :
  976.     case WILDCARD  :
  977.     case STRCELL   :
  978.     case CHARCELL  :
  979.     case INTCELL   : break;
  980.  
  981.     case ASPAT     : addPatVar(line,fst(snd(p)));
  982.              snd(snd(p)) = checkPat(line,snd(snd(p)));
  983.              break;
  984.  
  985.     case LAZYPAT   : snd(p) = checkPat(line,snd(p));
  986.              break;
  987.  
  988.     case FINLIST   : map1Over(checkPat,line,snd(p));
  989.              break;
  990.  
  991.     default        : ERROR(line) "Illegal pattern syntax"
  992.              EEND;
  993.     }
  994.     return p;
  995. }
  996.  
  997. static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with   */
  998. Int  l;                       /* the possibility of c*n or n+k    */
  999. Cell p; {                   /* pattern               */
  1000.     Cell h = getHead(p);
  1001.  
  1002.     if (argCount==2 && isVar(h)) {
  1003.     if (textOf(h)==textPlus) {  /* n+k pattern               */
  1004.         Cell v = arg(fun(p));
  1005.         if (!isInt(arg(p))) {
  1006.         ERROR(l) "Second argument in (n+k) pattern must be an integer"
  1007.         EEND;
  1008.         }
  1009.         if (intOf(arg(p))<=0) {
  1010.         ERROR(l) "Integer k in (n+k) pattern must be > 0"
  1011.         EEND;
  1012.         }
  1013.         fst(fun(p))     = ADDPAT;
  1014.         intValOf(fun(p)) = intOf(arg(p));
  1015.         arg(p)         = checkPat(l,v);
  1016.         return p;
  1017.     }
  1018.  
  1019.     if (textOf(h)==textMult) {  /* c*n pattern               */
  1020.         if (!isInt(arg(fun(p)))) {
  1021.         ERROR(l) "First argument in (c*n) pattern must be an integer"
  1022.         EEND;
  1023.         }
  1024.         if (intOf(arg(fun(p)))<=1) {
  1025.         ERROR(l) "Integer c in (c*n) pattern must be > 1"
  1026.         EEND;
  1027.         }
  1028.         fst(fun(p))      = MULPAT;
  1029.         intValOf(fun(p)) = intOf(arg(fun(p)));
  1030.         arg(p)           = checkPat(l,arg(p));
  1031.         return p;
  1032.     }
  1033.     }
  1034.  
  1035.     return checkApPat(l,0,p);
  1036. }
  1037.  
  1038. static Cell local checkApPat(line,args,p)
  1039. Int  line;                   /* check validity of application    */
  1040. Int  args;                   /* of constructor to arguments       */
  1041. Cell p; {
  1042.     switch (whatIs(p)) {
  1043.     case AP        : fun(p) = checkApPat(line,args+1,fun(p));
  1044.              arg(p) = checkPat(line,arg(p));
  1045.              break;
  1046.  
  1047.     case TUPLE     : if (tupleOf(p)!=args)
  1048.                  internal("bad pattern tuple");
  1049.              break;
  1050.  
  1051.     case CONIDCELL :
  1052.     case CONOPCELL : p = conDefined(line,textOf(p));
  1053.              checkCfunArgs(line,p,args);
  1054.              break;
  1055.  
  1056.     case NAME      : checkIsCfun(line,p);
  1057.              checkCfunArgs(line,p,args);
  1058.              break;
  1059.  
  1060.     default        : ERROR(line) "Illegal pattern syntax"
  1061.              EEND;
  1062.     }
  1063.     return p;
  1064. }
  1065.  
  1066. static Void local addPatVar(line,v)    /* add variable v to list of vars   */
  1067. Int  line;                   /* in current pattern, checking for */
  1068. Cell v; {                   /* repeated variables.           */
  1069.      Text t = textOf(v);
  1070.      List p = NIL;
  1071.      List n = patVars;
  1072.  
  1073.      for (; nonNull(n); p=n, n=tl(n))
  1074.      if (textOf(hd(n))==t) {
  1075.          ERROR(line) "Repeated variable \"%s\" in pattern",
  1076.              textToStr(t)
  1077.          EEND;
  1078.      }
  1079.  
  1080.      if (isNull(p))
  1081.      patVars = cons(v,NIL);
  1082.      else
  1083.      tl(p)     = cons(v,NIL);
  1084. }
  1085.  
  1086. static Name local conDefined(line,t)   /* check that t is the name of a    */
  1087. Int line;                   /* previously defined constructor   */
  1088. Text t; {                   /* function.               */
  1089.     Cell c=findName(t);
  1090.     if (isNull(c)) {
  1091.     ERROR(line) "Undefined constructor function \"%s\"", textToStr(t)
  1092.     EEND;
  1093.     }
  1094.     checkIsCfun(line,c);
  1095.     return c;
  1096. }
  1097.  
  1098. static Void local checkIsCfun(line,c)  /* Check that c is a constructor fn */
  1099. Int  line;
  1100. Cell c; {
  1101.     if (name(c).defn!=CFUN) {
  1102.     ERROR(line) "\"%s\" is not a constructor function",
  1103.             textToStr(name(c).text)
  1104.     EEND;
  1105.     }
  1106. }
  1107.  
  1108. static Void local checkCfunArgs(line,c,args)
  1109. Int  line;                   /* Check constructor applied with   */
  1110. Cell c;                    /* correct number of arguments       */
  1111. Int  args; {
  1112.     if (name(c).arity!=args) {
  1113.     ERROR(line) "Constructor function \"%s\" needs %d args in pattern",
  1114.             textToStr(name(c).text), name(c).arity
  1115.     EEND;
  1116.     }
  1117. }
  1118.  
  1119. /* --------------------------------------------------------------------------
  1120.  * Maintaining lists of bound variables and local definitions, for
  1121.  * dependency and scope analysis.
  1122.  * ------------------------------------------------------------------------*/
  1123.  
  1124. static List bounds;               /* list of lists of bound vars       */
  1125. static List bindings;               /* list of lists of binds in scope  */
  1126. static List depends;               /* list of lists of dependents       */
  1127.  
  1128. #define saveBvars()     hd(bounds)    /* list of bvars in current scope   */
  1129. #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */
  1130.  
  1131. static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
  1132. Int  line;
  1133. Cell p; {
  1134.     patVars    = NIL;
  1135.     p           = checkPat(line,p);
  1136.     hd(bounds) = revOnto(patVars,hd(bounds));
  1137.     return p;
  1138. }
  1139.  
  1140. static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
  1141. Int  line;
  1142. List ps; {
  1143.     patVars    = NIL;
  1144.     map1Over(checkPat,line,ps);
  1145.     hd(bounds) = revOnto(patVars,hd(bounds));
  1146. }
  1147.  
  1148. /* --------------------------------------------------------------------------
  1149.  * Before processing value and type signature declarations, all data and
  1150.  * type definitions have been processed so that:
  1151.  * - all valid type constructors (with their arities) are known.
  1152.  * - all valid constructor functions (with their arities and types) are
  1153.  *   known.
  1154.  *
  1155.  * The result of parsing a list of value declarations is a list of Eqns:
  1156.  *     Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
  1157.  * The ordering of the equations in this list is the reverse of the original
  1158.  * ordering in the script parsed.  This is a consequence of the structure of
  1159.  * the parser ... but also turns out to be most convenient for the static
  1160.  * analysis.
  1161.  *
  1162.  * As the first stage of the static analysis of value declarations, each
  1163.  * list of Eqns is converted to a list of Bindings.  As part of this
  1164.  * process:
  1165.  * - The ordering of the list of Bindings produced is the same as in the
  1166.  *   original script.
  1167.  * - When a variable (function) is defined over a number of lines, all
  1168.  *   of the definitions should appear together and each should give the
  1169.  *   same arity to the variable being defined.
  1170.  * - No variable can have more than one definition.
  1171.  * - For pattern bindings:
  1172.  *   - Each lhs is a valid pattern/function lhs, all constructor functions
  1173.  *     have been defined and are used with the correct number of arguments.
  1174.  *   - Each lhs contains no repeated pattern variables.
  1175.  *   - Each equation defines at least one variable (e.g. True = False is
  1176.  *     not allowed).
  1177.  * - Types appearing in type signatures are well formed:
  1178.  *    - Type constructors used are defined and used with correct number
  1179.  *    of arguments.
  1180.  *    - type variables are replaced by offsets, type constructor names
  1181.  *    by Tycons.
  1182.  * - Every variable named in a type signature declaration is defined by
  1183.  *   one or more equations elsewhere in the script.
  1184.  * - No variable has more than one type declaration.
  1185.  *
  1186.  * ------------------------------------------------------------------------*/
  1187.  
  1188. #define bindingType(b) fst(snd(b))     /* type (or types) for binding       */
  1189. #define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/
  1190.  
  1191. static List local extractSigdecls(es)  /* extract the SIGDECLS from list   */
  1192. List es; {                   /* of equations               */
  1193.     List sigDecls  = NIL;           /* :: [(Line,[Var],Type)]       */
  1194.  
  1195.     for(; nonNull(es); es=tl(es))
  1196.     if (fst(hd(es))==SIGDECL)             /* type-declaration?  */
  1197.         sigDecls = cons(snd(hd(es)),sigDecls);   /* discard SIGDECL tag*/
  1198.  
  1199.     return sigDecls;
  1200. }
  1201.  
  1202. static List local extractBindings(es)  /* extract untyped bindings from    */
  1203. List es; {                   /* given list of equations       */
  1204.     Cell lastVar   = NIL;           /* = var def'd in last eqn (if any) */
  1205.     Int  lastArity = 0;            /* = number of args in last defn    */
  1206.     List bs       = NIL;           /* :: [Binding]               */
  1207.  
  1208.     for(; nonNull(es); es=tl(es)) {
  1209.     Cell e = hd(es);
  1210.  
  1211.     if (fst(e)!=SIGDECL) {
  1212.         Int  line     = rhsLine(snd(e));
  1213.         Cell lhsHead = getHead(fst(e));
  1214.  
  1215.         switch (whatIs(lhsHead)) {
  1216.         case VARIDCELL :
  1217.         case VAROPCELL : {              /* function-binding? */
  1218.             Cell newAlt = pair(getArgs(fst(e)), snd(e));
  1219.             if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
  1220.             if (argCount!=lastArity) {
  1221.                 ERROR(line)
  1222.                 "Equations give different arities for \"%s\"",
  1223.                 textToStr(textOf(lhsHead))
  1224.                 EEND;
  1225.             }
  1226.             fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
  1227.             }
  1228.             else {
  1229.             lastVar   = lhsHead;
  1230.             lastArity = argCount;
  1231.             notDefined(line,bs,lhsHead);
  1232.             bs      = cons(pair(lhsHead,
  1233.                           pair(NIL,
  1234.                            singleton(newAlt))),
  1235.                      bs);
  1236.             }
  1237.         }
  1238.         break;
  1239.  
  1240.         case CONOPCELL :
  1241.         case CONIDCELL :
  1242.         case FINLIST   :
  1243.         case TUPLE     :
  1244.         case UNIT      :
  1245.         case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
  1246.                  patVars = NIL;
  1247.                  fst(e)  = checkPat(line,fst(e));
  1248.                  if (isNull(patVars)) {
  1249.                      ERROR(line)
  1250.                       "No variables defined in lhs pattern"
  1251.                      EEND;
  1252.                  }
  1253.                  map2Proc(notDefined,line,bs,patVars);
  1254.                  bs = cons(pair(patVars,pair(NIL,e)),bs);
  1255.                  break;
  1256.  
  1257.         default        : ERROR(line) "Improper left hand side"
  1258.                  EEND;
  1259.         }
  1260.     }
  1261.     }
  1262.     return bs;
  1263. }
  1264.  
  1265. static List local eqnsToBindings(es)   /* Convert list of equations to list*/
  1266. List es; {                   /* of typed bindings           */
  1267.     List bs = extractBindings(es);
  1268.     map1Proc(addSigDecl,bs,extractSigdecls(es));
  1269.     return bs;
  1270. }
  1271.  
  1272. static Void local notDefined(line,bs,v)/* check if name already defined in */
  1273. Int  line;                   /* list of bindings           */
  1274. List bs;
  1275. Cell v; {
  1276.     if (nonNull(findBinding(textOf(v),bs))) {
  1277.     ERROR(line) "\"%s\" multiply defined", textToStr(textOf(v))
  1278.     EEND;
  1279.     }
  1280. }
  1281.  
  1282. static Cell local findBinding(t,bs)    /* look for binding for variable t  */
  1283. Text t;                    /* in list of bindings bs       */
  1284. List bs; {
  1285.     for (; nonNull(bs); bs=tl(bs))
  1286.     if (isVar(fst(hd(bs)))) {              /* function-binding? */
  1287.         if (textOf(fst(hd(bs)))==t)
  1288.         return hd(bs);
  1289.     }
  1290.     else if (nonNull(varIsMember(t,fst(hd(bs))))) /* pattern-binding?  */
  1291.         return hd(bs);
  1292.     return NIL;
  1293. }
  1294.  
  1295. static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
  1296. List bs;                   /* :: [Binding]               */
  1297. Cell sigDecl; {                /* :: (Line,[Var],Type)           */
  1298.     Int  line = intOf(fst3(sigDecl));
  1299.     Cell vs   = snd3(sigDecl);
  1300.     Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
  1301.  
  1302.     map3Proc(setType,line,type,bs,vs);
  1303. }
  1304.  
  1305. static Void local setType(line,type,bs,v)
  1306. Int  line;                   /* Set type of variable           */
  1307. Cell type;
  1308. Cell v;
  1309. List bs; {
  1310.     Text t = textOf(v);
  1311.     Cell b = findBinding(t,bs);
  1312.  
  1313.     if (isNull(b)) {
  1314.     ERROR(line) "Type declaration for variable \"%s\" with no body",
  1315.             textToStr(t)
  1316.     EEND;
  1317.     }
  1318.  
  1319.     if (isVar(fst(b))) {                  /* function-binding? */
  1320.     if (isNull(bindingType(b))) {
  1321.         bindingType(b) = type;
  1322.         return;
  1323.     }
  1324.     }
  1325.     else {                          /* pattern-binding?  */
  1326.     List vs = fst(b);
  1327.     List ts = bindingType(b);
  1328.  
  1329.     if (isNull(ts))
  1330.         bindingType(b) = ts = copy(length(vs),NIL);
  1331.  
  1332.     while (nonNull(vs) && t!=textOf(hd(vs))) {
  1333.         vs = tl(vs);
  1334.         ts = tl(ts);
  1335.     }
  1336.  
  1337.     if (nonNull(vs) && isNull(hd(ts))) {
  1338.         hd(ts) = type;
  1339.         return;
  1340.     }
  1341.     }
  1342.  
  1343.     ERROR(line) "Repeated type declaration for \"%s\"", textToStr(t)
  1344.     EEND;
  1345. }
  1346.  
  1347. /* --------------------------------------------------------------------------
  1348.  * To facilitate dependency analysis, lists of bindings are temporarily
  1349.  * augmented with an additional field, which is used in two ways:
  1350.  * - to build the `adjacency lists' for the dependency graph. Represented by
  1351.  *   a list of pointers to other bindings in the same list of bindings.
  1352.  * - to hold strictly positive integer values (depth first search numbers) of
  1353.  *   elements `on the stack' during the strongly connected components search
  1354.  *   algorithm, or a special value mkInt(0), once the binding has been added
  1355.  *   to a particular strongly connected component.
  1356.  *
  1357.  * Using this extra field, the type of each list of declarations during
  1358.  * dependency analysis is [Binding'] where:
  1359.  *
  1360.  *    Binding' ::= (Var, (Dep, (Type, [Alt])))          -- function binding
  1361.  *        |  ([Var], (Dep, (Type, (Pat,Rhs))))  -- pattern binding
  1362.  *
  1363.  * ------------------------------------------------------------------------*/
  1364.  
  1365. #define depVal(d) (fst(snd(d)))        /* Access to dependency information */
  1366.  
  1367. static List local dependencyAnal(bs)   /* Separate lists of bindings into  */
  1368. List bs; {                   /* mutually recursive groups in       */
  1369.                        /* order of dependency           */
  1370.  
  1371.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  1372.     mapProc(depBinding,bs);           /* find dependents of each binding  */
  1373.     bs = bscc(bs);               /* sort to strongly connected comps */
  1374.     mapProc(remDepField,bs);           /* remove dependency info field       */
  1375.     return bs;
  1376. }
  1377.  
  1378. static List local topDependAnal(bs)    /* Like dependencyAnal(), but at    */
  1379. List bs; {                   /* top level, reporting on progress */
  1380.     List xs;
  1381.     Int  i = 0;
  1382.  
  1383.     setGoal("Dependency analysis",(Target)(length(bs)));
  1384.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  1385.     for (xs=bs; nonNull(xs); xs=tl(xs)) {
  1386.     depBinding(hd(xs));
  1387.     soFar((Target)(i++));
  1388.     }
  1389.     bs = bscc(bs);               /* sort to strongly connected comps */
  1390.     mapProc(remDepField,bs);           /* remove dependency info field       */
  1391.     done();
  1392.     return bs;
  1393. }
  1394.  
  1395. static Void local addDepField(b)       /* add extra field to binding to    */
  1396. Cell b; {                   /* hold list of dependents       */
  1397.     snd(b) = pair(NIL,snd(b));
  1398. }
  1399.  
  1400. static Void local remDepField(bs)      /* remove dependency field from       */
  1401. List bs; {                   /* list of bindings           */
  1402.     mapProc(remDepField1,bs);
  1403. }
  1404.  
  1405. static Void local remDepField1(b)      /* remove dependency field from       */
  1406. Cell b; {                   /* single binding           */
  1407.     snd(b) = snd(snd(b));
  1408. }
  1409.  
  1410. static Void local clearScope() {       /* initialise dependency scoping    */
  1411.     bounds   = NIL;
  1412.     bindings = NIL;
  1413.     depends  = NIL;
  1414. }
  1415.  
  1416. static Void local withinScope(bs)      /* enter scope of bindings bs       */
  1417. List bs; {
  1418.     bounds   = cons(NIL,bounds);
  1419.     bindings = cons(bs,bindings);
  1420.     depends  = cons(NIL,depends);
  1421. }
  1422.  
  1423. static Void local leaveScope() {       /* leave scope of last withinScope  */
  1424.     bounds   = tl(bounds);
  1425.     bindings = tl(bindings);
  1426.     depends  = tl(depends);
  1427. }
  1428.  
  1429. /* --------------------------------------------------------------------------
  1430.  * As a side effect of the dependency analysis we also make the following
  1431.  * checks:
  1432.  * - Each lhs is a valid pattern/function lhs, all constructor functions
  1433.  *   have been defined and are used with the correct number of arguments.
  1434.  * - No lhs contains repeated pattern variables.
  1435.  * - Expressions used on the rhs of an eqn should be well formed.  This
  1436.  *   includes:
  1437.  *   - Checking for valid patterns (including repeated vars) in lambda,
  1438.  *     case, and list comprehension expressions.
  1439.  *   - Recursively checking local lists of equations.
  1440.  * - No free (i.e. unbound) variables are used in the declaration list.
  1441.  * ------------------------------------------------------------------------*/
  1442.  
  1443. static Void local depBinding(b)        /* find dependents of binding       */
  1444. Cell b; {
  1445.     Cell defpart = snd(snd(snd(b)));   /* definition part of binding       */
  1446.  
  1447.     hd(depends) = NIL;
  1448.  
  1449.     if (isVar(fst(b))) {           /* function-binding?           */
  1450.     mapProc(depAlt,defpart);
  1451.     }
  1452.     else {                   /* pattern-binding?           */
  1453.     depRhs(snd(defpart));
  1454.     }
  1455.  
  1456.     depVal(b) = hd(depends);
  1457. }
  1458.  
  1459. static Void local depDefaults(c)       /* dependency analysis on defaults  */
  1460. Class c; {                             /* from class definition            */
  1461.     depClassBindings(class(c).defaults);
  1462. }
  1463.  
  1464. static Void local depInsts(in)         /* dependency analysis on instance  */
  1465. Inst in; {                             /* bindings                         */
  1466.     depClassBindings(inst(in).implements);
  1467. }
  1468.  
  1469. static Void local depClassBindings(bs) /* dependency analysis on list of   */
  1470. List bs; {                             /* bindings, possibly containing    */
  1471.     for (; nonNull(bs); bs=tl(bs))     /* NIL bindings ...                 */
  1472.         if (nonNull(hd(bs)))           /* No need to add extra field for   */
  1473.             mapProc(depAlt,name(hd(bs)).defn); /* dependency information.. */
  1474. }
  1475.  
  1476. static Void local depAlt(a)           /* find dependents of alternative   */
  1477. Cell a; {
  1478.     List origBvars = saveBvars();      /* save list of bound variables       */
  1479.     bindPats(rhsLine(snd(a)),fst(a));  /* add new bound vars for patterns  */
  1480.     depRhs(snd(a));               /* find dependents of rhs       */
  1481.     restoreBvars(origBvars);           /* restore original list of bvars   */
  1482. }
  1483.  
  1484. static Void local depRhs(r)           /* find dependents of rhs       */
  1485. Cell r; {
  1486.     switch (whatIs(r)) {
  1487.     case GUARDED : mapProc(depGuard,snd(r));
  1488.                break;
  1489.  
  1490.     case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
  1491.                withinScope(fst(snd(r)));
  1492.                fst(snd(r)) = dependencyAnal(fst(snd(r)));
  1493.                hd(depends) = fst(snd(r));
  1494.                depRhs(snd(snd(r)));
  1495.                leaveScope();
  1496.                break;
  1497.  
  1498.     default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
  1499.                break;
  1500.     }
  1501. }
  1502.  
  1503. static Void local depGuard(g)           /* find dependents of single guarded*/
  1504. Cell g; {                   /* expression               */
  1505.     depPair(intOf(fst(g)),snd(g));
  1506. }
  1507.  
  1508. static Cell local depExpr(line,e)      /* find dependents of expression    */
  1509. Int  line;
  1510. Cell e; {
  1511.     switch (whatIs(e)) {
  1512.  
  1513.     case VARIDCELL    :
  1514.     case VAROPCELL    : return depVar(line,e);
  1515.  
  1516.     case CONIDCELL    :
  1517.     case CONOPCELL    : return conDefined(line,textOf(e));
  1518.  
  1519.     case AP     : depPair(line,e);
  1520.               break;
  1521.  
  1522.     case NAME    :
  1523.     case UNIT    :
  1524.     case TUPLE    :
  1525.     case STRCELL    :
  1526.     case CHARCELL    :
  1527.     case FLOATCELL  :
  1528.     case INTCELL    : break;
  1529.  
  1530.     case COND    : depTriple(line,snd(e));
  1531.               break;
  1532.  
  1533.     case FINLIST    : map1Over(depExpr,line,snd(e));
  1534.               break;
  1535.  
  1536.     case LETREC    : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
  1537.               withinScope(fst(snd(e)));
  1538.               fst(snd(e)) = dependencyAnal(fst(snd(e)));
  1539.               hd(depends) = fst(snd(e));
  1540.               snd(snd(e)) = depExpr(line,snd(snd(e)));
  1541.               leaveScope();
  1542.               break;
  1543.  
  1544.     case LAMBDA    : depAlt(snd(e));
  1545.               break;
  1546.  
  1547.     case COMP    : depComp(line,snd(e),snd(snd(e)));
  1548.               break;
  1549.  
  1550.     case ESIGN    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  1551.               snd(snd(e)) = checkSigType(line,
  1552.                              "expression",
  1553.                              fst(snd(e)),
  1554.                              snd(snd(e)));
  1555.               break;
  1556.  
  1557.     case CASE    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  1558.               map1Proc(depCaseAlt,line,snd(snd(e)));
  1559.               break;
  1560.  
  1561.     case ASPAT    : ERROR(line) "Illegal `@' in expression"
  1562.               EEND;
  1563.  
  1564.     case LAZYPAT    : ERROR(line) "Illegal `~' in expression"
  1565.               EEND;
  1566.  
  1567.     case WILDCARD    : ERROR(line) "Illegal `_' in expression"
  1568.               EEND;
  1569.  
  1570.     default     : internal("in depExpr");
  1571.    }
  1572.    return e;
  1573. }
  1574.  
  1575. static Void local depPair(line,e)    /* find dependents of pair of exprs*/
  1576. Int  line;
  1577. Cell e; {
  1578.     fst(e) = depExpr(line,fst(e));
  1579.     snd(e) = depExpr(line,snd(e));
  1580. }
  1581.  
  1582. static Void local depTriple(line,e)    /* find dependents of triple exprs */
  1583. Int  line;
  1584. Cell e; {
  1585.     fst3(e) = depExpr(line,fst3(e));
  1586.     snd3(e) = depExpr(line,snd3(e));
  1587.     thd3(e) = depExpr(line,thd3(e));
  1588. }
  1589.  
  1590. static Void local depComp(l,e,qs)    /* find dependents of comprehension*/
  1591. Int  l;
  1592. Cell e;
  1593. List qs; {
  1594.     if (isNull(qs))
  1595.     fst(e) = depExpr(l,fst(e));
  1596.     else {
  1597.     Cell q   = hd(qs);
  1598.     List qs1 = tl(qs);
  1599.     switch (whatIs(q)) {
  1600.         case FROMQUAL : {   List origBvars = saveBvars();
  1601.                                 snd(snd(q))    = depExpr(l,snd(snd(q)));
  1602.                 fst(snd(q))    = bindPat(l,fst(snd(q)));
  1603.                 depComp(l,e,qs1);
  1604.                 restoreBvars(origBvars);
  1605.                 }
  1606.                 break;
  1607.  
  1608.         case QWHERE   : snd(q)      = eqnsToBindings(snd(q));
  1609.                 withinScope(snd(q));
  1610.                             snd(q)      = dependencyAnal(snd(q));
  1611.                 hd(depends) = snd(q);
  1612.                 depComp(l,e,qs1);
  1613.                 leaveScope();
  1614.                 break;
  1615.  
  1616.         case BOOLQUAL : snd(q) = depExpr(l,snd(q));
  1617.                 depComp(l,e,qs1);
  1618.                 break;
  1619.     }
  1620.     }
  1621. }
  1622.  
  1623. static Void local depCaseAlt(line,a)    /* find dependents of case altern. */
  1624. Int  line;
  1625. Cell a; {
  1626.     List origBvars = saveBvars();    /* save list of bound variables       */
  1627.     fst(a) = bindPat(line,fst(a));    /* add new bound vars for patterns */
  1628.     depRhs(snd(a));            /* find dependents of rhs       */
  1629.     restoreBvars(origBvars);        /* restore original list of bvars  */
  1630. }
  1631.  
  1632. static Cell local depVar(line,e)    /* register occurrence of variable */
  1633. Int line;
  1634. Cell e; {
  1635.     List bounds1   = bounds;
  1636.     List bindings1 = bindings;
  1637.     List depends1  = depends;
  1638.     Text t       = textOf(e);
  1639.     Cell n;
  1640.  
  1641.     while (nonNull(bindings1)) {
  1642.     n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
  1643.     if (nonNull(n))
  1644.         return n;
  1645.  
  1646.     n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
  1647.     if (nonNull(n)) {
  1648.        if (!cellIsMember(n,hd(depends1)))
  1649.            hd(depends1) = cons(n,hd(depends1));
  1650.        return (isVar(fst(n)) ? fst(n) : e);
  1651.     }
  1652.  
  1653.     bounds1   = tl(bounds1);
  1654.     bindings1 = tl(bindings1);
  1655.     depends1  = tl(depends1);
  1656.     }
  1657.  
  1658.     if (isNull(n=findName(t))) {           /* check global definitions */
  1659.     ERROR(line) "Undefined variable \"%s\"", textToStr(t)
  1660.     EEND;
  1661.     }
  1662.  
  1663.     return n;
  1664. }
  1665.  
  1666. /* --------------------------------------------------------------------------
  1667.  * Several parts of this program require an algorithm for sorting a list
  1668.  * of values (with some added dependency information) into a list of strongly
  1669.  * connected components in which each value appears before its dependents.
  1670.  *
  1671.  * Each of these algorithms is obtained by parameterising a standard
  1672.  * algorithm in "scc.c" as shown below.
  1673.  * ------------------------------------------------------------------------*/
  1674.  
  1675. #define visited(d) (isInt(DEPENDS(d)))    /* binding already visited ?       */
  1676.  
  1677. static Cell daSccs = NIL;
  1678. static Int  daCount;
  1679.  
  1680. static Int local sccMin(x,y)           /* calculate minimum of x,y (unless */
  1681. Int x,y; {                   /* y is zero)               */
  1682.     return (x<=y || y==0) ? x : y;
  1683. }
  1684.  
  1685. #define  SCC        tscc        /* make scc algorithm for Tycons   */
  1686. #define  LOWLINK    tlowlink
  1687. #define  DEPENDS(t) tycon(t).kind
  1688. #include "scc.c"
  1689. #undef     DEPENDS
  1690. #undef      LOWLINK
  1691. #undef     SCC
  1692.  
  1693. #define  SCC        cscc        /* make scc algorithm for Classes  */
  1694. #define  LOWLINK    clowlink
  1695. #define  DEPENDS(c) class(c).sig
  1696. #include "scc.c"
  1697. #undef     DEPENDS
  1698. #undef      LOWLINK
  1699. #undef     SCC
  1700.  
  1701. #define  SCC        bscc        /* make scc algorithm for Bindings */
  1702. #define  LOWLINK    blowlink
  1703. #define  DEPENDS(t) depVal(t)
  1704. #include "scc.c"
  1705. #undef     DEPENDS
  1706. #undef      LOWLINK
  1707. #undef     SCC
  1708.  
  1709. /* --------------------------------------------------------------------------
  1710.  * Main static analysis:
  1711.  * ------------------------------------------------------------------------*/
  1712.  
  1713. Void checkExp() {            /* Top level static check on Expr  */
  1714.     staticAnalysis(RESET);
  1715.     clearScope();            /* Analyse expression in the scope */
  1716.     withinScope(NIL);            /* of no local bindings           */
  1717.     inputExpr = depExpr(0,inputExpr);
  1718.     leaveScope();
  1719.     staticAnalysis(RESET);
  1720. }
  1721.  
  1722. Void checkDefns() {            /* Top level static analysis       */
  1723.     staticAnalysis(RESET);
  1724.  
  1725.     mapProc(checkTyconDefn,tyconDefns);    /* validate tycon definitions       */
  1726.     checkSynonyms(tyconDefns);        /* check synonym definitions       */
  1727.     tyconDefns = tscc(tyconDefns);    /* sort into sc components       */
  1728.     mapProc(checkTyconGroup,tyconDefns);/* validate each group           */
  1729.     tyconDefns = NIL;
  1730.  
  1731.     mapProc(checkClassDefn,classDefns);    /* process class definitions       */
  1732.     mapProc(checkClassGroup,cscc(classDefns));
  1733.  
  1734.     instDefns = rev(instDefns);        /* process instance definitions       */
  1735.     mapProc(checkInstDefn,instDefns);
  1736.  
  1737.     mapProc(addRSsigdecls,typeInDefns);    /* add sigdecls for RESTRICTSYN       */
  1738.     valDefns = eqnsToBindings(valDefns);/* translate value equations       */
  1739.     map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound       */
  1740.     mapProc(allNoPrevDef,valDefns);    /* check against previous defns       */
  1741.  
  1742.     mapProc(checkTypeIn,typeInDefns);    /* check restricted synonym defns  */
  1743.  
  1744.     clearScope();
  1745.     withinScope(valDefns);
  1746.     valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
  1747.     mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
  1748.     mapProc(depInsts,instDefns);        /* dep. analysis on inst defns       */
  1749.     leaveScope();
  1750.  
  1751.     staticAnalysis(RESET);
  1752. }
  1753.  
  1754. static Void local addRSsigdecls(pr)    /* add sigdecls from TYPE ... IN ..*/
  1755. Pair pr; {
  1756.     List vs = snd(pr);            /* get list of variables       */
  1757.     for (; nonNull(vs); vs=tl(vs)) {
  1758.     if (fst(hd(vs))==SIGDECL) {    /* find a sigdecl           */
  1759.         valDefns = cons(hd(vs),valDefns);    /* add to valDefns       */
  1760.         hd(vs)   = hd(snd3(snd(hd(vs))));    /* and replace with var       */
  1761.     }
  1762.     }
  1763. }
  1764.  
  1765. static Void local opDefined(bs,op)     /* check that op bound in bs       */
  1766. List bs;                 /* (or in current module for       */
  1767. Cell op; {                 /* constructor functions etc...)  */
  1768.     Name n;
  1769.  
  1770.     if (isNull(findBinding(textOf(op),bs))
  1771.            && (isNull(n=findName(textOf(op))) || !nameThisModule(n))) {
  1772.     ERROR(0) "No top level definition for operator symbol \"%s\"",
  1773.          textToStr(textOf(op))
  1774.     EEND;
  1775.     }
  1776. }
  1777.  
  1778. static Void local allNoPrevDef(b)     /* ensure no previous bindings for*/
  1779. Cell b; {                 /* variables in new binding       */
  1780.     if (isVar(fst(b)))
  1781.     noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
  1782.     else {
  1783.     Int line = rhsLine(snd(snd(snd(b))));
  1784.     map1Proc(noPrevDef,line,fst(b));
  1785.     }
  1786. }
  1787.  
  1788. static Void local noPrevDef(line,v)     /* ensure no previous binding for */
  1789. Int  line;                 /* new variable           */
  1790. Cell v; {
  1791.     Name n = findName(textOf(v));
  1792.  
  1793.     if (isNull(n)) {
  1794.     n            = newName(textOf(v));
  1795.     name(n).defn = PREDEFINED;
  1796.     }
  1797.     else if (name(n).defn!=PREDEFINED) {
  1798.     ERROR(line) "Attempt to redefine variable \"%s\"",
  1799.             textToStr(name(n).text)
  1800.     EEND;
  1801.     }
  1802.     name(n).line = line;
  1803. }
  1804.  
  1805. static Void local checkTypeIn(cvs)    /* Check that vars in restricted   */
  1806. Pair cvs; {                /* synonym are defined, and replace*/
  1807.     Tycon c  = fst(cvs);        /* vars with names           */
  1808.     List  vs = snd(cvs);
  1809.  
  1810.     for (; nonNull(vs); vs=tl(vs))
  1811.     if (isNull(findName(textOf(hd(vs))))) {
  1812.         ERROR(tycon(c).line)
  1813.         "No top level binding of \"%s\" for restricted synonym \"%s\"",
  1814.         textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
  1815.         EEND;
  1816.     }
  1817. }
  1818.  
  1819. /* --------------------------------------------------------------------------
  1820.  * Static Analysis control:
  1821.  * ------------------------------------------------------------------------*/
  1822.  
  1823. Void staticAnalysis(what)
  1824. Int what; {
  1825.     switch (what) {
  1826.     case INSTALL :
  1827.     case RESET   : daSccs     = NIL;
  1828.                patVars     = NIL;
  1829.                bounds     = NIL;
  1830.                bindings     = NIL;
  1831.                depends   = NIL;
  1832.                tyconDeps = NIL;
  1833.                break;
  1834.  
  1835.     case MARK    : mark(daSccs);
  1836.                mark(patVars);
  1837.                mark(bounds);
  1838.                mark(bindings);
  1839.                mark(depends);
  1840.                mark(tyconDeps);
  1841.                break;
  1842.     }
  1843. }
  1844.  
  1845. /*-------------------------------------------------------------------------*/
  1846.